home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / XLISP1 / lisp / QUEENS2 < prev    next >
Lisp/Scheme  |  1990-02-23  |  3KB  |  86 lines
  1. ;
  2. ; Place n queens on a board (graphical version)
  3. ;  See Winston and Horn Ch. 11
  4. ;
  5. ; Usage:
  6. ;       (queens <n>)
  7. ;          where <n> is an integer -- the size of the board - try (queens 4)
  8.  
  9. (defun cadar (x)
  10.   (car (cdr (car x))))
  11.  
  12. ; Do two queens threaten each other ?
  13. (defun threat (i j a b)
  14.   (or (equal i a)                       ;Same row
  15.       (equal j b)                       ;Same column
  16.       (equal (- i j) (- a b))           ;One diag.
  17.       (equal (+ i j) (+ a b))))         ;the other diagonal
  18.  
  19. ; Is poistion (n,m) on the board safe for a queen ?
  20. (defun conflict (n m board)
  21.   (cond ((null board) nil)
  22.         ((threat n m (caar board) (cadar board)) t)
  23.         (t (conflict n m (cdr board)))))
  24.  
  25.  
  26. ; Place queens on a board of size SIZE
  27. (defun queens (size)
  28.   (prog (n m board soln)
  29.         (setq soln 0)                   ;Solution #
  30.         (setq board nil)
  31.         (setq n 1)                      ;Try the first row
  32.         loop-n
  33.         (setq m 1)                      ;Column 1
  34.         loop-m
  35.         (cond ((conflict n m board) (go un-do-m))) ;Check for conflict
  36.         (setq board (cons (list n m) board))       ; Add queen to board
  37.         (cond ((> (setq n (1+ n)) size)            ; Placed N queens ?
  38.                (print-board (reverse board) (setq soln (1+ soln))))) ; Print it
  39.         (go loop-n)                                ; Next row which column?
  40.         un-do-n
  41.         (cond ((null board) (return 'Done))        ; Tried all possibilities
  42.               (t (setq m (cadar board))            ; No, Undo last queen placed
  43.                  (setq n (caar board))
  44.                  (setq board (cdr board))))
  45.  
  46.         un-do-m
  47.         (cond ((> (setq m (1+ m)) size)          ; Go try next column
  48.                (go un-do-n))
  49.               (t (go loop-m)))))
  50.  
  51.  
  52. ;Print a board
  53. (defun print-board  (board soln &aux size)
  54.   (setq size (length board))            ;we can find our own size
  55.   (terpri)
  56.   (princ "\t\tSolution: ")
  57.   (print soln)
  58.   (terpri)
  59.   (princ "\t")
  60.   (print-header size 1)
  61.   (terpri)
  62.   (print-board-aux board size 1)
  63.   (terpri))
  64.  
  65. ; Put Column #'s on top
  66. (defun print-header (size n)
  67.   (cond ((> n size) terpri)
  68.         (t (princ n)
  69.            (princ " ")
  70.            (print-header size (1+ n)))))
  71.  
  72. (defun print-board-aux (board size row)
  73.   (terpri)
  74.   (cond ((null board))
  75.         (t (princ row)                  ;print the row #
  76.            (princ "\t")
  77.            (print-board-row (cadar board) size 1) ;Print the row
  78.            (print-board-aux (cdr board) size (1+ row)))))  ;Next row
  79.  
  80. (defun print-board-row (column size n)
  81.   (cond ((> n size))
  82.         (t (cond ((equal column n) (princ "Q"))
  83.                  (t (princ ".")))
  84.            (princ " ")
  85.            (print-board-row column size (1+ n)))))
  86.